{-# LANGUAGE TypeFamilies               #-}
{-# OPTIONS -Wall #-}

--------------------------------------------------------------------------------
-- |
-- Module      :  Lirio.Base.RelDuration
-- Copyright   :  (c) Stephen Tetley 2012
-- License     :  BSD3
--
-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>
-- Stability   :  highly unstable
-- Portability :  GHC
--
-- Relative duration (and absolute pitch) note-list monad.
--
--------------------------------------------------------------------------------


module Lirio.Base.RelDuration
  (
  
    DRelative
  , runNotelist

  , resetAll

  ) where

import Lirio.Base.CatDoc hiding ( newline )
import qualified Lirio.Base.CatDoc as C
import Lirio.Base.Duration
import Lirio.Base.LyPrims
import Lirio.Base.Overloading
import Lirio.Base.Pitch

import Text.PrettyPrint.Leijen hiding ( dot )   -- package: wl-pprint

import Control.Applicative hiding ( empty )
import Data.Monoid hiding ( (<>) )

data State ust = State 
    { rel_drn       :: !Duration
    , user_state    :: ust 
    }

-- | Initial values \"guaranteed\" not to match.
--
stateZero :: ust -> State ust 
stateZero s0 = State { rel_drn    = dot $ dot $ dot $ dBreve
                     , user_state = s0 }


newtype DRelative ust a = DRelative { 
    getDRelative :: State ust -> (a, State ust, CatDoc) }



instance Functor (DRelative ust) where
  fmap f ma = DRelative $ \s -> let (a,s1,w) = getDRelative ma s in (f a,s1,w)

instance Applicative (DRelative ust) where
  pure a    = DRelative $ \s -> (a,s,mempty)
  mf <*> ma = DRelative $ \s -> let (f,s1,w1) = getDRelative mf s
                                    (a,s2,w2) = getDRelative ma s1
                                in (f a, s2, w1 `mappend` w2)       

instance Monad (DRelative ust) where
  return   = pure
  ma >>= k = DRelative $ \s -> let (a,s1,w1) = getDRelative ma s 
                                   (b,s2,w2) = getDRelative (k a) s1
                               in (b, s2, w1 `mappend` w2)

instance Monoid a => Monoid (DRelative ust a) where
  mempty = pure mempty
  ma `mappend` mb = DRelative $ \s -> let (a,s1,w1) = getDRelative ma s
                                          (b,s2,w2) = getDRelative mb s1
                                      in (a `mappend` b,s2, w1 `mappend` w2)



type instance Ust (DRelative ust) = ust

instance UserStateM (DRelative ust) where
  get     = DRelative $ \s -> (user_state s,s,mempty)
  set ust = DRelative $ \s -> ((),s { user_state = ust} ,mempty)


-- Can\'t be an instance of CxReset...
--
-- instance CxReset DRelative where
--   reset = DRelative $ \_ -> ((), state_zero, mempty)


{-
-- | DRelative is /run/ within a Score. Final duration is lost..
--
notelist :: DRelative ust a -> Score ust a
notelist ma = withScore $ \s -> 
    let (a,s1,w) = getDRelative ma $ stateZero s
    in (a, user_state s1, renderCatDoc w) 
-}

runNotelist :: ust -> DRelative ust a -> (a, ust, Doc) 
runNotelist ss ma = 
    let (a,s1,w) = getDRelative ma (stateZero ss) 
    in (a, user_state s1, renderCatDoc w)


resetAll :: ust -> DRelative ust ()
resetAll st = DRelative $ \_ -> ((), stateZero st, mempty)



deltaDuration :: Duration -> DRelative ust (Maybe Duration)
deltaDuration d = DRelative $ \s -> 
    let d0 = rel_drn s in
    if d0 == d then (Nothing,s,mempty)
               else (Just d,s { rel_drn = d }, mempty)


tellC :: CatDoc -> DRelative ust () 
tellC w = DRelative $ \s -> ((),s,w)

applyT :: (CatDoc -> CatDoc) -> DRelative ust a -> DRelative ust a
applyT fn ma = DRelative $ \s -> let (a,s1,w1) = getDRelative ma s
                                 in (a,s1, fn w1)   


--------------------------------------------------------------------------------
-- Overloading instances

instance HasCommandM (DRelative ust) where
  command = tellC . commandC 

instance HasNewlineM (DRelative ust) where
  newline = tellC $ C.newline

instance NoteListM (DRelative ust)

instance GenericMarkM (DRelative ust) where
  genericMark doc = tellC $ genericMarkC doc

instance GenericEventM (DRelative ust) where
  genericEvent doc d = do
      dn <- deltaDuration d
      tellC $ genericEventC doc dn


instance HasRestM (DRelative ust)
instance HasSpacerM (DRelative ust)



type instance Pch (DRelative ust) = Pitch

instance NoteM (DRelative ust) where
  note p d = do 
      dn <- deltaDuration d
      tellC $ noteC p dn

instance ChordM (DRelative ust) where 
  chord ps d = do
      dn <- deltaDuration d
      tellC $ chordC ps dn

instance GroupingM (DRelative ust) where
  prefix d = applyT (C.prefix d)
  suffix d = applyT (C.suffix d)
